SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00003 1 08-24-9413:58ALL LUIS MEZQUITA Sort an Array of Record SWAG9408 ─C½≡ 18 S {π TB>> I am having a bit of difficulty figuring out how toπ TB>> sort an array of records by numerical or alphabetical order.π TB>> Here's an example of my record set up:ππ This a 'small' example of record quicksort.π}ππProgram SortArrayOfRec;ππuses Crt;ππtypeππ Str34=string[34];ππ Rec=Recordπ Name:Str34;π Number1,π Number2 : LongInt;π end;ππtype CmpMinFunc=Function(var r1,r2:Rec):boolean;ππvarππ RecArray:array[1..1400] of Rec;ππ{ Compare functions }ππFunction Name(var r1,r2:Rec):boolean; far;πbeginπ Name:=r1.Name<r2.Name;πend;ππFunction Number1(var r1,r2:Rec):boolean; far;πbeginπ Number1:=r1.Number1<r2.Number1;πend;ππFunction Number2(var r1,r2:Rec):boolean; far;πbeginπ Number2:=r1.Number2<r2.Number2;πend;ππ{ QuickSort method }ππProcedure Sort(t,b:integer; Cmp:CmpMinFunc);ππProcedure QuickSort(l,r:integer);πvar i,j:integer; x,y:Rec;πbeginπ i:=l;π j:=r;π x:=RecArray[(l+r) div 2];π repeatπ while Cmp(RecArray[i],x) do inc(i);π while Cmp(x,RecArray[j]) do dec(j);π if i<=jπ then beginπ y:=RecArray[i];π RecArray[i]:=RecArray[j];π RecArray[j]:=y;π inc(i);π dec(j);π end;π until i>j;π if l<j then QuickSort(l,j);π if i<r then QuickSort(i,r);πend;ππbegin { Procedure Sort }π QuickSort(t,b);πend;ππ{ Demo procedures }ππProcedure List(s:string);πvar n:byte;πbeginπ WriteLn(s);π for n:=1 to 9 doπ with RecArray[n] doπ WriteLn(n,' ',Name,Number1:6,Number2:6);π WriteLn;π n:=Ord(ReadKey);πend;ππvar n:byte;ππbeginπ ClrScr;π Randomize;π for n:=1 to 9 do { Fill RecArray with ... }π with RecArray[n] do { random datas }π beginπ Name:=Chr(65+Random(25));π Number1:=Random(65535);π Number2:=Random(65535);π end;π List('Datas');ππ Sort(1,9,Name); { Sort on Name }π List('Sort on Name');π Sort(1,9,Number1); { Sort on Number1 }π List('Sort on Number1');π Sort(1,9,Number2); { Sort on Number2 }π List('Sort on Number2');πend.π 2 08-24-9413:58ALL CHRISTIAN TIBERG Alphabetical Order SWAG9408 ∙─z 16 S π{ This unit will sort ANY type of data into ANY type of order. As an addedπbonus, there are a routine to search through a sorted list of ANY type...πCredits go to Björn Felten for his QSort unit, which inspired me to write thisπroutine }ππUnit SortSrch;ππinterfaceππTypeπ CompFunc = Function(Item1, Item2: Integer): Integer;π SwapProc = Procedure(Item1, Item2: Integer);π CompOneFunc = Function(Item: Integer): Integer;ππProcedure QuickSort(First, Last: Integer; Comp: CompFunc; Swap: SwapProc);πFunction BinarySearch(First, Last: Integer; CompOne: CompOneFunc): Integer;ππimplementationππProcedure Partition(First, Last: Integer; Var SplitIndex: Integer;π Comp: CompFunc; Swap: SwapProc);ππ Varπ Up, Down, Middle: Integer;ππ Beginπ Middle := ((Last - First) DIV 2 ) + First;π Up := First;π Down := Last;π Repeatπ While (Comp(Up, Middle) <= 0) And (Up < Last) Do Inc(Up);π While (Comp(Down, Middle) > 0) And (Down > First) Do Dec(Down);π If Up < Down Thenπ Swap(Up, Down);π Until Up >= Down;π SplitIndex := Down;π Swap(Middle, SplitIndex);π End;ππProcedure QuickSort(First, Last: Integer; Comp: CompFunc; Swap: SwapProc);ππ Varπ SplitIndex: Integer;ππ Beginπ If First < Last Thenπ Beginπ Partition(First, Last, SplitIndex, Comp, Swap);π QuickSort(First, SplitIndex - 1, Comp, Swap);π QuickSort(SplitIndex + 1, Last, Comp, Swap);π End;π End;ππFunction BinarySearch(First, Last: Integer; CompOne: CompOneFunc): Integer;ππ Varπ Middle, Jfr: Integer;ππ Beginπ Repeatπ Middle := ((Last - First) DIV 2 ) + First;π Jfr := CompOne(Middle);π If Jfr = 0 Thenπ Beginπ BinarySearch := Middle;π Exit;π Endπ Else If Jfr > 0 Thenπ First := Middleπ Elseπ Last := Middle;π Until First = Last;π BinarySearch := -1;π End;ππend.π 3 08-24-9417:53ALL BRAD WILLIAMS TV Sorting unit SWAG9408 óWG╖ 150 S {*******************************************************************}π{ }π{ WVS Software Company }π{ Turbo Pascal Sorting Unit for TCollections }π{ Usage Fee: None, public domain }π{ Version: 1.0 }π{ Release Date: 6/27/93 }π{ }π{ Programmer: Brad Williams }π{ E-mail : bwilliams@marvin.ag.uidaho.edu }π{ US Mail : 1008 E. 7th }π{ Moscow, Idaho 83843 }π{ }π{*******************************************************************}π{ }π{ This unit contains objects for performing various types of }π{ sorts. To use any of the sorting methods, simply pass them a }π{ collection and a compare or test function. You can write your }π{ programs to accept a TSortProcedure/TSearchFunction as a }π{ parameter to any function or procedure and use whichever type }π{ of sort/search you require at that point in your program. The }π{ search and sort methods accept pointers to compare and test }π{ functions so that the same functions can be used for iterative }π{ procedures/functions in a TSortedCollection. }π{ }π{*******************************************************************}πUNIT TVSorts;π{****************************************************************************}π INTERFACEπ{****************************************************************************}πUSES Objects;ππTYPEπ TCompareFunction = FUNCTION (Item1, Item2 : Pointer) : Integer;π { A TCompareFunction must return: }π { 1 if the Item1 > Item2 }π { 0 if the Item1 = Item2 }π { -1 if the Item1 < Item2 }ππ TSortProcedure = PROCEDURE (ACollection : PCollection;π Compare : TCompareFunction);ππ { Sort Procedures }πPROCEDURE BinaryInsertionSort (ACollection : PCollection;π Compare : TCompareFunction);πPROCEDURE BubbleSort (ACollection : PCollection; Compare : TCompareFunction);πPROCEDURE CombSort (ACollection : PCollection; Compare : TCompareFunction);πPROCEDURE HeapSort (ACollection : PCollection; Compare : TCompareFunction);πPROCEDURE QuickSort (ACollection : PCollection; Compare : TCompareFunction);πPROCEDURE QuickSortNonRecursive (ACollection : PCollection;π Compare : TCompareFunction);πPROCEDURE ShakerSort (ACollection : PCollection; Compare : TCompareFunction);πPROCEDURE ShellSort (ACollection : PCollection; Compare : TCompareFunction);πPROCEDURE StraightInsertionSort (ACollection : PCollection;π Compare : TCompareFunction);πPROCEDURE StraightSelectionSort (ACollection : PCollection;π Compare : TCompareFunction);πPROCEDURE TreeSort (ACollection : PCollection; Compare : TCompareFunction);πππ { Compare Procedures - Must write your own Compare for pointer variables. }π { This allows one sort routine to be used on any array. }πFUNCTION CompareChars (Item1, Item2 : Pointer) : Integer; FAR;πFUNCTION CompareInts (Item1, Item2 : Pointer) : Integer; FAR;πFUNCTION CompareLongInts (Item1, Item2 : Pointer) : Integer; FAR;πFUNCTION CompareReals (Item1, Item2 : Pointer) : Integer; FAR;πFUNCTION CompareStrs (Item1, Item2 : Pointer) : Integer; FAR;ππ{****************************************************************************}π IMPLEMENTATIONπ{****************************************************************************}π{ }π{ Local Procedures and Functions }π{ }π{****************************************************************************}πPROCEDURE Swap (ACollection : PCollection; A, B : Integer);πVAR Item : Pointer;πBEGINπ Item := ACollection^.At(A);π ACollection^.AtPut(A,ACollection^.At(B));π ACollection^.AtPut(B,Item);πEND;π{****************************************************************************}π{ }π{ Global Procedures and Functions }π{ }π{****************************************************************************}πPROCEDURE BinaryInsertionSort (ACollection : PCollection;π Compare : TCompareFunction);πVAR i, j, Middle, Left, Right : LongInt;πBEGINπ FOR i := 0 TO (ACollection^.Count - 1) DOπ BEGINπ Left := 0;π Right := i;π WHILE Left < Right DOπ BEGINπ Middle := (Left + Right) DIV 2;π WITH ACollection^ DOπ IF Compare(At(Middle),At(i)) < 1π THEN Left := Middle + 1π ELSE Right := Middle;π END;π FOR j := i DOWNTO (Right + 1) DOπ Swap(ACollection,j,j-1);π END;πEND;π{****************************************************************************}πPROCEDURE BubbleSort (ACollection : PCollection; Compare : TCompareFunction);πVAR i, j : Integer;πBEGINπ WITH ACollection^ DOπ FOR i := 1 TO (Count - 1) DOπ FOR j := (Count - 1) DOWNTO i DOπ IF Compare(At(j-1),At(j)) = 1π THEN Swap(ACollection,j,j-1);πEND;π{****************************************************************************}πPROCEDURE CombSort (ACollection : PCollection; Compare : TCompareFunction);π { The combsort is an optimised version of the bubble sort. It uses a }π { decreasing gap in order to compare values of more than one element }π { apart. By decreasing the gap the array is gradually "combed" into }π { order ... like combing your hair. First you get rid of the large }π { tangles, then the smaller ones ... }π { }π { There are a few particular things about the combsort. Firstly, the }π { optimal shrink factor is 1.3 (worked out through a process of }π { exhaustion by the guys at BYTE magazine). Secondly, by never }π { having a gap of 9 or 10, but always using 11, the sort is faster. }π { }π { This sort approximates an n log n sort - it's faster than any }π { other sort I've seen except the quicksort (and it beats that too }π { sometimes ... have you ever seen a quicksort become an (n-1)^2 }π { sort ... ?). The combsort does not slow down under *any* }π { circumstances. In fact, on partially sorted lists (including }π { *reverse* sorted lists) it speeds up. }π { }π { More information in the April 1991 BYTE magazine. }πCONST ShrinkFactor = 1.3;πVAR Gap, i : LongInt;π Finished : Boolean;πBEGINπ Gap := Round((ACollection^.Count-1)/ShrinkFactor);π WITH ACollection^ DOπ REPEATπ Finished := TRUE;π Gap := Trunc(Gap/ShrinkFactor);π IF Gap < 1π THEN Gap := 1π ELSE IF ((Gap = 9) OR (Gap = 10))π THEN Gap := 11;π FOR i := 0 TO ((Count - 1) - Gap) DOπ IF Compare(At(i),At(i+Gap)) = 1π THEN BEGINπ Swap(ACollection,i,i+gap);π Finished := False;π END;π UNTIL ((Gap = 1) AND Finished);πEND;π{****************************************************************************}πPROCEDURE HeapSort (ACollection : PCollection; Compare : TCompareFunction);π { Performs best when items are in inverse order. }πVAR L, R : LongInt;π X : Pointer;π {*****************************************}π PROCEDURE Sift;π VAR i, j : LongInt;π Label 13;π BEGINπ i := L;π j := 2 * i;π X := ACollection^.At(i);π WITH ACollection^ DOπ WHILE j <= R DOπ BEGINπ IF j < Rπ THEN IF Compare(At(j),At(j+1)) = -1π THEN Inc(j);π IF Compare(X,At(j)) >= 0π THEN GoTo 13;π AtPut(i,At(j));π i := j;π j := 2 * i;π END;π 13: ACollection^.AtPut(i,X);π END;π {*****************************************}πBEGINπ L := ((ACollection^.Count - 1) DIV 2) + 1;π R := ACollection^.Count - 1;π WHILE L > 0 DOπ BEGINπ Dec(L);π Sift;π END;π WHILE R > 0 DOπ BEGINπ X := ACollection^.At(1);π Swap(ACollection,0,R);π Dec(R);π Sift;π END;πEND;π{****************************************************************************}πPROCEDURE QuickSort (ACollection : PCollection; Compare : TCompareFunction);π {****************************************************************}π PROCEDURE Sort (Left, Right : LongInt);π VAR i, j : LongInt;π X : Pointer;π BEGINπ WITH ACollection^ DOπ BEGINπ i := Left;π j := Right;π X := At((Left + Right) DIV 2);π REPEATπ WHILE Compare(At(i),X) = -1 DO Inc(i);π WHILE Compare(X,At(j)) = -1 DO Dec(j);π IF i <= jπ THEN BEGINπ Swap(ACollection,i,j);π Inc(i);π Dec(j)π END;π UNTIL i > j;π IF Left < jπ THEN Sort(Left,j);π IF i < Rightπ THEN Sort(i,Right)π END;π END;π {****************************************************************}πBEGINπ Sort(0,ACollection^.Count-1);πEND;π{****************************************************************************}πPROCEDURE QuickSortNonRecursive (ACollection : PCollection;π Compare : TCompareFunction);πCONST m = 12;πVAR i, j, L, R : LongInt;π x : Pointer;π s : 0..m;π Stack : ARRAY[1..m] OF RECORDπ l, r : LongInt;π END;πBEGINπ s := 1;π Stack[1].l := 0;π Stack[1].r := ACollection^.Count - 1;π WITH ACollection^ DOπ REPEATπ L := Stack[s].l;π R := Stack[s].r;π Dec(S);π REPEATπ i := L;π j := R;π x := At((L + R) DIV 2);π REPEATπ WHILE Compare(x,At(i)) = 1 DO Inc(i);π WHILE Compare(x,At(j)) = -1 DO Dec(j);π IF i <= jπ THEN BEGINπ Swap(ACollection,i,j);π Inc(i);π Dec(j);π END;π UNTIL i > j;π IF i < Rπ THEN BEGINπ Inc(s);π Stack[s].l := i;π Stack[s].r := R;π END;π R := j;π UNTIL L >= R;π UNTIL s = 0;πEND;π{****************************************************************************}πPROCEDURE ShakerSort (ACollection : PCollection; Compare : TCompareFunction);π { Works for any array and any index range. }πVAR j, k, Left, Right : LongInt;πBEGINπ Left := 1;π Right := (ACollection^.Count - 1);π k := Right;π WITH ACollection^ DOπ REPEATπ FOR j := Right DOWNTO Left DOπ IF Compare(At(j-1),At(j)) = 1π THEN BEGINπ Swap(ACollection,j,j-1);π k := j;π END;π Left := k + 1;π FOR j := Left TO Right DOπ IF Compare(At(j-1),At(j)) = 1π THEN BEGINπ Swap(ACollection,j,j-1);π k := j;π END;π Right := k - 1;π UNTIL Left > Right;πEND;π{****************************************************************************}πPROCEDURE ShellSort (ACollection : PCollection; Compare : TCompareFunction);πVAR Gap, i, j, k : LongInt;πBEGINπ Gap := (ACollection^.Count - 1) DIV 2;π WHILE (Gap > 0) DOπ BEGINπ FOR i := Gap TO (ACollection^.Count - 1) DOπ BEGINπ j := i - Gap;π WHILE (j > -1) DOπ BEGINπ k := j + Gap;π IF Compare(ACollection^.At(j),ACollection^.At(k)) < 1π THEN j := 0π ELSE Swap(ACollection,j,k);π Dec(j,Gap);π END;π END;π Gap := Gap DIV 2;π END;πEND;π{****************************************************************************}πPROCEDURE StraightInsertionSort (ACollection : PCollection;π Compare : TCompareFunction);πVAR i, j : LongInt;π X : Pointer;πBEGINπ WITH ACollection^ DOπ FOR i := 0 TO (Count - 1) DOπ BEGINπ X := At(i);π j := i;π WHILE (j > 0) AND (Compare(X,At(j-1)) = -1) DOπ BEGINπ AtPut(j,At(j-1));π Dec(j);π END;π AtPut(j,X);π END;πEND;π{****************************************************************************}πPROCEDURE StraightSelectionSort (ACollection : PCollection;π Compare : TCompareFunction);πVAR i, j, k : LongInt;πBEGINπ FOR i := 0 TO (ACollection^.Count - 1) DOπ BEGINπ k := i;π FOR j := (i + 1) TO (ACollection^.Count - 1) DOπ IF Compare(ACollection^.At(j),ACollection^.At(k)) = -1π THEN k := j;π Swap(ACollection,i,k);π END;πEND;π{****************************************************************************}πPROCEDURE TreeSort (ACollection : PCollection; Compare : TCompareFunction);π{after D.Cooke, A.H.Craven, G.M.Clarke: Statistical Computingπ in Pascal, Publisher: Edward Arnold, London 1985 ISBN 0-7131-3545-X }πTYPE PNode = ^Node;π Node = RECORDπ Value : Pointer;π Left : PNode;π Right : PNode;π END;πVAR Add, Top : PNode;π i : LongInt;π {***********************************************************}π PROCEDURE MakeTree (VAR Node : PNode);π BEGINπ IF Node = NILπ THEN Node := Addπ ELSE IF Compare(Add^.Value,Node^.Value) = 1π THEN MakeTree(Node^.Right)π ELSE MakeTree(Node^.Left);π END;π {**********************************************************}π PROCEDURE StripTree (Node : PNode);π BEGINπ IF Node <> NILπ THEN BEGINπ StripTree(Node^.Left);π ACollection^.AtPut(i,Node^.Value);π Inc(i);π StripTree(Node^.Right)π END;π END;π {**********************************************************}πBEGINπ Top := NIL;π FOR i := 0 TO (ACollection^.Count - 1) DOπ BEGINπ New(Add);π Add^.Value := ACollection^.At(i);π Add^.Left := NIL;π Add^.Right := NIL;π MakeTree(Top)π END;π i := 0;π StripTree(Top)πEND;π{****************************************************************************}π{ }π{ Compare Procedures }π{ }π{****************************************************************************}πFUNCTION CompareChars (Item1, Item2 : Pointer) : Integer;πBEGINπ IF Char(Item1^) < Char(Item2^)π THEN CompareChars := -1π ELSE CompareChars := Ord(Char(Item1^) <> Char(Item2^));πEND;π{*****************************************************************************}πFUNCTION CompareInts (Item1, Item2 : Pointer) : Integer;πBEGINπ IF Integer(Item1^) < Integer(Item2^)π THEN CompareInts := -1π ELSE CompareInts := Ord(Integer(Item1^) <> Integer(Item2^));πEND;π{*****************************************************************************}πFUNCTION CompareLongInts (Item1, Item2 : Pointer) : Integer;πBEGINπ IF LongInt(Item1^) < LongInt(Item2^)π THEN CompareLongInts := -1π ELSE CompareLongInts := Ord(LongInt(Item1^) <> LongInt(Item2^));πEND;π{*****************************************************************************}πFUNCTION CompareReals (Item1, Item2 : Pointer) : Integer;πBEGINπ IF Real(Item1^) < Real(Item2^)π THEN CompareReals := -1π ELSE CompareReals := Ord(Real(Item1^) <> Real(Item2^));πEND;π{*****************************************************************************}πFUNCTION CompareStrs (Item1, Item2 : Pointer) : Integer;πBEGINπ IF String(Item1^) < String(Item2^)π THEN CompareStrs := -1π ELSE CompareStrs := Ord(String(Item1^) <> String(Item2^));πEND;π{*****************************************************************************}πBEGINπEND.ππ{ ----------------------------------- DEMO PROGRAM ---------------------}ππPROGRAM Test;πUSES Crt, Objects, TVSorts;ππCONSTπ MaxCollectionSize = 10;ππVAR C : TCollection;π i, j, k : Integer;π Ch : ^Char;ππBEGINπ Randomize;π FOR i := 1 TO 11 DOπ BEGINπ { initialize collection and load with data in reverse order }π C.Init(MaxCollectionSize,1);π FOR j := MaxCollectionSize DOWNTO 0 DOπ BEGINπ k := Random(255);π WHILE (k < 65) OR (k > 90) DO k := Random(255);π New(Ch);π Ch^ := Char(k);π C.AtInsert(0,Ch);π END;π { display unsorted data }π ClrScr;π CASE i OFπ 1 : WriteLn('Binary Insertion Sort');π 2 : WriteLn('Bubble Sort');π 3 : WriteLn('Comb Sort');π 4 : WriteLn('Heap Sort');π 5 : WriteLn('Quick Sort');π 6 : WriteLn('Non-recursive Quick Sort');π 7 : WriteLn('Shaker Sort');π 8 : WriteLn('Shell Sort');π 9 : WriteLn('Straight Insertion Sort');π 10 : WriteLn('Straight Selection Sort');π 11 : WriteLn('Tree Sort');π END;π FOR j := 0 TO (C.Count - 1) DO Write(Char(C.At(j)^):2);π { sort data }π CASE i OFπ 1 : BinaryInsertionSort(@C,CompareChars);π 2 : BubbleSort(@C,CompareChars);π 3 : CombSort(@C,CompareChars);π 4 : HeapSort(@C,CompareChars);π 5 : QuickSort(@C,CompareChars);π 6 : QuickSortNonRecursive(@C,CompareChars);π 7 : ShakerSort(@C,CompareChars);π 8 : ShellSort(@C,CompareChars);π 9 : StraightInsertionSort(@C,CompareChars);π 10 : StraightSelectionSort(@C,CompareChars);π 11 : TreeSort(@C,CompareChars);π END;π { display sorted data }π WriteLn;π FOR j := 0 TO (C.Count - 1) DO Write(Char(C.At(j)^):2);π ReadLn;π { clear of collection }π END;πEND.
